home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / defcal.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  5.7 KB  |  175 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module defcal macro)
  13. ;; Compile-time support for defining things which dispatch
  14. ;; off the property list. The Macsyma parser uses this.
  15.  
  16. (DEFUN CHECK-SUBR-ARGL (L)
  17.   (IF (OR (> (LENGTH L) 5.)
  18.       (MEMQ '&REST L)
  19.       (MEMQ '&OPTIONAL L)
  20.       (MEMQ '&RESTV L)
  21.       (MEMQ '"E L))
  22.       (MAXIMA-ERROR "Can't DEF-PROPL-CALL with non-subr arglist" L)))
  23.  
  24. (DEFVAR USE-SUBRCALL
  25.   #+CL NIL
  26.   #+MACLISP T
  27.   #+NIL NIL)
  28.  
  29. (DEFMACRO DEF-PROPL-CALL (NAME (OP . L) DEFAULT-ACTION
  30.                    &AUX
  31.                    (TEMP (GENSYM))
  32.                    (SUBR? (IF USE-SUBRCALL
  33.                       (LIST (SYMBOLCONC NAME '-SUBR))
  34.                       ())))
  35.   (IF SUBR? (CHECK-SUBR-ARGL L))
  36.   `(PROGN 'COMPILE
  37.           #+lispm   (si:record-source-file-name ',name 'def-propl-call)
  38.       (DEFMACRO ,(SYMBOLCONC 'DEF- NAME '-EQUIV) (OP EQUIV)
  39.            #+lispm  (declare (si:function-parent ,name 'def-propl-call))
  40.         `(PUTPROP ',OP #',EQUIV ',',NAME))
  41.       (DEFMACRO ,(SYMBOLCONC NAME '-PROPL) ()
  42.         #+lispm  (declare (si:function-parent ,name 'def-propl-call))
  43.  
  44.         ''(,NAME ,@SUBR?))
  45.       (DEFMACRO ,(SYMBOLCONC 'DEF- NAME '-FUN) (OP-NAME OP-L . BODY)
  46. ;        #+lispm  (declare (si:function-parent ,name 'def-propl-call))
  47. ;        `(DEFUN (,OP-NAME ,',NAME  ,@',SUBR?)
  48. ;            ,OP-L . ,BODY))
  49.         `(DEFUN-prop (,OP-NAME ,',NAME  ,@',SUBR?)
  50.             ,OP-L
  51.                    #+lispm  (declare (si:function-parent ,op-name 'def-nud-fun))
  52.            ,@ BODY))
  53.       (DEFUN ,(SYMBOLCONC NAME '-CALL) (,OP . ,L)
  54.         #+lispm  (declare (si:function-parent ,name 'def-propl-call))
  55.         (LET ((,TEMP (AND (SYMBOLP ,OP)
  56.                   (GETL ,OP '(,NAME ,@SUBR?)))))
  57.           (IF (NULL ,TEMP)
  58.           ,DEFAULT-ACTION
  59.           ,(IF SUBR?
  60.                `(IF (EQ (CAR ,TEMP) ',(CAR SUBR?))
  61.                 (SUBRCALL NIL (CADR ,TEMP) ,OP ,@L)
  62.                 (FUNCALL (CADR ,TEMP) ,OP ,@L))
  63.                `(FUNCALL (CADR ,TEMP) ,OP ,@L)))))))
  64.  
  65.  
  66. (DEFUN MAKE-PARSER-FUN-DEF (OP P BVL BODY)
  67.   ;; Used by the Parser at compile time.
  68.   (IF (NOT (consp OP))
  69.       `(,(SYMBOLCONC 'DEF- P '-FUN) ,OP ,BVL
  70.                     ,(CAR BVL)
  71.                     ;; so compiler won't warn about
  72.                     ;; unused lambda variable.
  73.                     . ,BODY)
  74.       `(PROGN 'COMPILE
  75.           ,(MAKE-PARSER-FUN-DEF (CAR OP) P BVL BODY)
  76.           ,@(MAPCAR #'(LAMBDA (X)
  77.                 `(INHERIT-PROPL ',X ',(CAR OP)
  78.                         (,(SYMBOLCONC P '-PROPL))))
  79.             (CDR OP)))))
  80.  
  81.  
  82. ;;; The tokenizer use the famous CSTR to represent the possible extended token
  83. ;;; symbols. The derivation of the name and implementation is obscure, but I've
  84. ;;; heard it has something to do with an early Fortran compiler written in Lisp.
  85. ;;;  -GJC
  86.  
  87. ;;; (CSTRSETUP <description>)
  88. ;;;
  89. ;;;  <description> ::= (<descriptor> <descriptor> ...)
  90. ;;;  <descriptor>  ::= <name> ! (<name> <translation>)
  91. ;;;  
  92. ;;;  If no translation is supplied, $<name> is the default.
  93. ;;;  
  94. ;;;  Sets up a CSTR [Command STRucture] object which may be used
  95. ;;;  in conjunction with the CEQ predicate to determine if the
  96. ;;;  LINBUF cursor is currently pointing at any keyword in that 
  97. ;;;  structure.
  98. ;;;  
  99. ;;;  Note: Names containing shorter names as initial segments
  100. ;;;        must follow the shorter names in arg to CSTRSETUP.
  101.  
  102. (DEFVAR SYMBOLS-DEFINED () "For safe keeping.")
  103. (DEFVAR MACSYMA-OPERATORS ())
  104.  
  105. (eval-when (eval compile load)
  106.   (DEFUN *DEFINE-INITIAL-SYMBOLS (L)
  107.     (SETQ SYMBOLS-DEFINED
  108.       (SORT (copy-list L) #'(LAMBDA (X Y) (< (FLATC X) (FLATC Y)))))
  109.     (SETQ MACSYMA-OPERATORS (CSTRSETUP SYMBOLS-DEFINED)))
  110.   )
  111.  
  112.  
  113. (DEFMACRO DEFINE-INITIAL-SYMBOLS (&REST L)
  114.   (LET ((SYMBOLS-DEFINED ())
  115.     (MACSYMA-OPERATORS ()))
  116.     (*DEFINE-INITIAL-SYMBOLS L)
  117.     `(PROGN 'COMPILE
  118.         (DECLARE-TOP (SPECIAL SYMBOLS-DEFINED MACSYMA-OPERATORS))
  119.         (SETQ SYMBOLS-DEFINED (copy-list ',SYMBOLS-DEFINED))
  120.         (SETQ MACSYMA-OPERATORS (SUBST () () ',MACSYMA-OPERATORS)))))
  121.  
  122. (DEFUN UNDEFINE-SYMBOL (OP)
  123.   (*DEFINE-INITIAL-SYMBOLS (DELQ (STRIPDOLLAR OP) SYMBOLS-DEFINED)))
  124.  
  125. (DEFUN DEFINE-SYMBOL (X)
  126.   (SETQ X (STRIPDOLLAR X))
  127.   (*DEFINE-INITIAL-SYMBOLS (CONS X SYMBOLS-DEFINED))
  128.   ;(IMPLODE (CONS #/$ (EXPLODEN X)))
  129.   (symbolconc '$ x))
  130.  
  131. (DEFUN CSTRSETUP (ARG)
  132.   (DO ((ARG ARG (CDR ARG)) (TREE NIL))
  133.       ((NULL ARG) (LIST* () '(ANS ()) TREE))
  134.     (COND ((ATOM (CAR ARG))
  135.        (SETQ TREE 
  136.          (ADD2CSTR (CAR ARG) 
  137.                TREE 
  138.                ;(IMPLODE (CONS '$ (EXPLODEC (CAR ARG))))
  139.                (symbolconc '$ (car arg))
  140.                )))
  141.       (T
  142.        (SETQ TREE 
  143.          (ADD2CSTR (CAAR ARG) TREE (CADAR ARG)))))))
  144.    
  145. ;;; (ADD2CSTR <name> <tree> <translation>)
  146. ;;; 
  147. ;;;  Adds the information <name> -> <translation> to a 
  148. ;;;  CSTR-style <tree>.
  149.  
  150. (DEFUN ADD2CSTR (X TREE ANS) 
  151.   (ADD2CSTR1 (NCONC (EXPLODEN X) (NCONS (LIST 'ANS ANS)))
  152.          TREE))
  153.    
  154. ;;; (ADD2CSTR1 <translation-info> <tree>)
  155. ;;;
  156. ;;;  Helping function for ADD2CSTR. Puts information about a 
  157. ;;;  keyword into the <tree>
  158.  
  159. (DEFUN ADD2CSTR1 (X TREE)
  160.   (COND ((NULL TREE) X)
  161.     ((ATOM (CAR TREE))
  162.      (COND ((EQUAL (CAR TREE) (CAR X))
  163.         (RPLACD TREE (ADD2CSTR1 (CDR X) (CDR TREE))))
  164.            (T (LIST TREE (COND ((ATOM (CAR X)) X)
  165.                    ((EQUAL (CAAR X) 'ANS) (CAR X))
  166.                    (T X))))))
  167.     ((EQUAL (CAAR TREE) (CAR X))
  168.      (RPLACD (CAR TREE) (ADD2CSTR1 (CDR X) (CDAR TREE)))
  169.      TREE)
  170.     ((NULL (CDR TREE))
  171.      (RPLACD TREE (LIST X))
  172.      TREE)
  173.     (T (RPLACD TREE (ADD2CSTR1 X (CDR TREE)))
  174.        TREE)))
  175.